Visual Basic Source Code/Visual Basic Source Code.iso/vbsource/ftpser1a/windproc.bas

BASIC Source File | 1999-10-04 | 5.6 KB | 128 lines

Attribute VB_Name = "WindProc"
Option Explicit

Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Public Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal wndrpcPrev As Long, ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Public Const GWL_WNDPROC = (-4)

Public intSocket As Integer
Public OldWndProc As Long
Public IPDot As String

Public Function WindowProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long

Dim retf As Long
Dim SendBuffer As String, Msg$
Dim lenBuffer As Integer 'send-buffer lenght
Dim RecvBuffer As String
Dim BytesRead As Integer 'receive-buffer lenght
Dim i As Integer, GoAhead As Boolean
Dim fixstr As String * 1024
Dim lct As String
Dim lcv As Integer
Dim WSAEvent As Long
Dim WSAError As Long
  GoAhead = True
  Select Case uMsg
  Case 5150
    ServerLog "NOTIFICATION - " & wParam & " - " & lParam & "> " & Format$(Date$, "dd/mm/yy ") & Format$(Time$, "hh:mm - ")
    If (wParam = ServerSlot) Or (wParam = NewSlot) Then 'event on server slot
      'ftpserv.StatusBar.Panels(1) = CStr(wParam)
      WSAEvent = WSAGetSelectEvent(lParam)
      WSAError = WSAGetAsyncError(lParam)
      'Debug.Print "Retf = "; WSAEvent; WSAError
      Select Case WSAEvent
        'FD_READ    = &H1    = 1
        'FD_WRITE   = &H2    = 2
        'FD_OOB     = &H4    = 4
        'FD_ACCEPT  = &H8    = 8
        'FD_CONNECT = &H10   = 16
        'FD_CLOSE   = &H20   = 32
      Case FD_CONNECT
        Debug.Print "FD_Connect " & wParam; lParam
        retf = getpeername(NewSlot, SockAddr, SockAddr_Size)
        Debug.Print "Peername = " & retf
        Debug.Print "IPAddr1 =" & SockAddr.sin_addr
        Debug.Print "IPPort1 =" & SockAddr.sin_port
      Case FD_ACCEPT
        Debug.Print "Doing FD_Accept"

        SockAddr.sin_family = AF_INET
        SockAddr.sin_port = 0
        'SockAddr.sin_addr = 0
        NewSlot = accept(ServerSlot, SockAddr, SockAddr_Size) 'try to accept new TCP connection
        If NewSlot = INVALID_SOCKET Then
          Msg$ = "Can't accept new socket."
          'ftpserv.StatusBar.Panels(1) = Msg$ & CStr(NewSlot)

        Else
          Debug.Print "NewSlot OK "; NewSlot; num_users; MAX_N_USERS
          retf = getpeername(NewSlot, SockAddr, SockAddr_Size)
          IPDot = GetAscIP(SockAddr.sin_addr)
          FtpServ.StatusBar.Panels(1) = IPDot & "<>" & vbGetHostByAddress(IPDot)
          Debug.Print "Peername = " & retf
          Debug.Print "IPAddr2 =" & SockAddr.sin_addr & " IPdot=" & IPDot
          Debug.Print "IPPort2 =" & SockAddr.sin_port & " Port:" & ntohs(SockAddr.sin_port)
          If num_users >= MAX_N_USERS Then        'new service request
            'the number of users exceeds the maximum allowed
            SendBuffer = "421 Service not available at this time, closing control connection." & vbCrLf
            lenBuffer = Len(SendBuffer)
            retf = send(NewSlot, SendBuffer, lenBuffer, 0)
            retf = closesocket(NewSlot)           'close connection
          Else
            SendBuffer = "220-Welcome to my demo Server v0.0.1!" & vbCrLf _
                       & "220 This program is written in VB 5.0" & vbCrLf
            lenBuffer = Len(SendBuffer)
            retf = send(NewSlot, SendBuffer, lenBuffer, 0)          'send welcome message
            Debug.Print "Send = " & retf
            num_users = num_users + 1      'increases the number of connected users
            FtpServ.UsrCnt = CStr(num_users)
            For i = 1 To MAX_N_USERS       'registers the slot number in the first free user record
              If Not users(i).full Then
                users(i).control_slot = NewSlot
                users(i).full = True
                Exit For
              End If
            Next
          End If  'If num_users
        End If  'If NewSlot
      Case FD_READ
        Debug.Print "Doing FD_Read"
        BytesRead = recv(wParam, fixstr, 1024, 0) 'store read bytes in RecvBuffer
        RecvBuffer = Left$(fixstr, BytesRead)
        If InStr(RecvBuffer, vbCrLf) > 0 Then     'if received string is a command then executes it
          For i = 1 To MAX_N_USERS                'event on control slots
            If (wParam = users(i).control_slot) Then
              retf = exec_FTP_cmd(i, RecvBuffer)
            End If
          Next
        End If
      Case FD_CLOSE
        Debug.Print "Doing FD_Close"
        For i = 1 To MAX_N_USERS  'event on control slots
          If (wParam = users(i).control_slot) Then
            retf = closesocket(wParam)        'connection closed by client
            users(i).control_slot = INVALID_SOCKET        'frees the user record
            users(i).full = False
            ServerLog "<" & Format$(i, "000") & "> " & Format$(Date$, "dd/mm/yy ") & Format$(Time$, "hh:mm") & " - Logged Off"
            num_users = num_users - 1
            FtpServ.UsrCnt = CStr(num_users)
            Exit For
          ElseIf (wParam = users(i).data_slot) Then
            retf = closesocket(wParam)        'connection closed by client
            users(i).data_slot = INVALID_SOCKET   'reinitilizes data slot
            users(i).state = 2
            Exit For
          End If
       Next
      Case FD_WRITE
        Debug.Print "Doing FD_Write"
        'enables sending
      End Select
    End If
    'Debug.Print GetWSAErrorString(WSAGetLastError)
  End Select
    retf = CallWindowProc(OldWndProc, hWnd, uMsg, wParam, ByVal lParam)
    WindowProc = retf
End Function